home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Advanced V211776152001.psc / modBMP.bas < prev    next >
Encoding:
BASIC Source File  |  2001-04-19  |  3.5 KB  |  92 lines
  1. Attribute VB_Name = "modBMP"
  2. '*****************************************************************
  3. '*              Bitmap file creation subroutines                 *
  4. '*              written by Chavdar Yordanov, 04.2001             *
  5. '*              Email: chavo@beer.com                            *
  6. '*              Please, don't remove this title!                 *
  7. '*****************************************************************
  8.  
  9. Option Explicit
  10.  
  11. '-----------------------------------------------------------------
  12. '- Creates a BMP file on the disk containing the bitmap          -
  13. '- Please, note that bBitMap array already contains the          -
  14. '- bitmap color information. This function just adds             -
  15. '- the bitmap header and saves the data to the disk.             -
  16. '-----------------------------------------------------------------
  17. Public Sub Create24bitBitmap(ByVal bmpHeight, ByVal bmpWidth, bBitmap() As Byte, sbmpFileName As String)
  18.     
  19.     Dim bBytes() As Byte        'will contain a long or integer value split to bytes
  20.     Dim bmpDiskSize As Long     'Bitmap size on the disk
  21.     Dim bmpImgSize As Long      'Bitmap image size = height x width in pixels
  22.     Dim cPos As Long            'Current position within the bBitMap array. Set by MergeBytes sub
  23.     Dim i As Long, j As Long    'Counters
  24.     Dim FNo As Integer          'The free file number
  25.     
  26.     Const bmpOffset = 54        'header size in bytes
  27.     Const bmpResolution = 3780  'pels per meter default x and y resolution
  28.     Const biSize = 40           '
  29.     Const bitCount = 24         'color depth in bits
  30.     Const bitType = 19778       'Letters BM as double-byte WORD (the first two bytes of the file data)
  31.     Const bitPlanes = 1         'fixed to 1
  32.     Const bitCompression = 0    'this bitmap is non-compressed
  33.     
  34.     cPos = 0
  35.     bmpImgSize = bmpHeight * bmpWidth
  36.     bmpDiskSize = bmpOffset + bmpImgSize * bitCount / 8
  37.     
  38.     SplitIntoBytes bitType, 2, bBytes()
  39.     MergeBytes bBitmap(), bBytes(), cPos
  40.     
  41.     SplitIntoBytes bmpDiskSize, 4, bBytes()
  42.     MergeBytes bBitmap(), bBytes(), cPos
  43.     
  44.     cPos = cPos + 4 'skipping 2 reserved WORDs
  45.     
  46.     SplitIntoBytes bmpOffset, 4, bBytes()
  47.     MergeBytes bBitmap(), bBytes(), cPos
  48.     
  49.     SplitIntoBytes biSize, 4, bBytes()
  50.     MergeBytes bBitmap(), bBytes(), cPos
  51.     
  52.     SplitIntoBytes bmpWidth, 4, bBytes()
  53.     MergeBytes bBitmap(), bBytes(), cPos
  54.     
  55.     SplitIntoBytes bmpHeight, 4, bBytes()
  56.     MergeBytes bBitmap(), bBytes(), cPos
  57.     
  58.     SplitIntoBytes bitPlanes, 2, bBytes()
  59.     MergeBytes bBitmap(), bBytes(), cPos
  60.     
  61.     SplitIntoBytes bitCount, 2, bBytes()
  62.     MergeBytes bBitmap(), bBytes(), cPos
  63.     
  64.     SplitIntoBytes bitCompression, 4, bBytes()
  65.     MergeBytes bBitmap(), bBytes(), cPos
  66.     
  67.     SplitIntoBytes bmpImgSize, 4, bBytes()
  68.     MergeBytes bBitmap(), bBytes(), cPos
  69.     
  70.     SplitIntoBytes bmpResolution, 4, bBytes()
  71.     MergeBytes bBitmap(), bBytes(), cPos
  72.     
  73.     SplitIntoBytes bmpResolution, 4, bBytes()
  74.     MergeBytes bBitmap(), bBytes(), cPos
  75.     
  76.     FNo = FreeFile
  77.     Open sbmpFileName For Binary Access Write As #FNo
  78.     Put #FNo, , bBitmap()
  79.     Close #FNo
  80.     
  81. End Sub
  82.  
  83. '------------- Inserts contents of bFraction into bAll array at lCurrPosition ----
  84. Public Sub MergeBytes(ByRef bAll() As Byte, ByRef bFraction() As Byte, ByRef lCurrPosition As Long)
  85.     Dim i
  86.     For i = 1 To UBound(bFraction)
  87.         bAll(lCurrPosition + i) = bFraction(i)
  88.     Next i
  89.     lCurrPosition = lCurrPosition + i - 1
  90. End Sub
  91.  
  92.